home *** CD-ROM | disk | FTP | other *** search
/ Supercompiler 1997 / SUPERCOMPILER97.iso / Delphi 3.0 / DATA.Z / dbcommon.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-01-29  |  25.7 KB  |  944 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Delphi Visual Component Library                 }
  5. {       Additional BDE dependent Classes                }
  6. {                                                       }
  7. {       Copyright (c) 1995,96 Borland International     }
  8. {                                                       }
  9. {*******************************************************}
  10.  
  11. unit DBCommon;
  12.  
  13. interface
  14.  
  15. uses Windows, Classes, DB, BDE;
  16.  
  17. { FieldType Mappings }
  18.  
  19. const
  20.   FldTypeMap: array[TFieldType] of Byte = (
  21.     fldUNKNOWN, fldZSTRING, fldINT16, fldINT32, fldUINT16, fldBOOL,
  22.     fldFLOAT, fldFLOAT, fldBCD, fldDATE, fldTIME, fldTIMESTAMP, fldBYTES,
  23.     fldVARBYTES, fldINT32, fldBLOB, fldBLOB, fldBLOB, fldBLOB, fldBLOB,
  24.     fldBLOB, fldBLOB, fldCURSOR);
  25.  
  26.   FldSubTypeMap: array[TFieldType] of Word = (
  27.     0, 0, 0, 0, 0, 0, 0, fldstMONEY, 0, 0, 0, 0, 0, 0, fldstAUTOINC,
  28.     fldstBINARY, fldstMEMO, fldstGRAPHIC, fldstFMTMEMO, fldstOLEOBJ,
  29.     fldstDBSOLEOBJ, fldstTYPEDBINARY, 0);
  30.  
  31.   DataTypeMap: array[0..MAXLOGFLDTYPES - 1] of TFieldType = (
  32.     ftUnknown, ftString, ftDate, ftBlob, ftBoolean, ftSmallint,
  33.     ftInteger, ftFloat, ftBCD, ftBytes, ftTime, ftDateTime,
  34.     ftWord, ftInteger, ftUnknown, ftVarBytes, ftUnknown, ftUnknown);
  35.  
  36.   BlobTypeMap: array[fldstMEMO..fldstTYPEDBINARY] of TFieldType = (
  37.     ftMemo, ftBlob, ftFmtMemo, ftParadoxOle, ftGraphic,
  38.     ftDBaseOle, ftTypedBinary);
  39.  
  40. { TFilterExpr }
  41.  
  42. type
  43.  
  44.   TExprNodeKind = (enField, enConst, enOperator);
  45.  
  46.   PExprNode = ^TExprNode;
  47.   TExprNode = record
  48.     FNext: PExprNode;
  49.     FKind: TExprNodeKind;
  50.     FPartial: Boolean;
  51.     FOperator: CanOp;
  52.     FData: Variant;
  53.     FLeft: PExprNode;
  54.     FRight: PExprNode;
  55.   end;
  56.  
  57.   TFilterExpr = class
  58.   private
  59.     FDataSet: TDataSet;
  60.     FOptions: TFilterOptions;
  61.     FNodes: PExprNode;
  62.     FExprBuffer: PCANExpr;
  63.     FExprBufSize: Integer;
  64.     FExprNodeSize: Integer;
  65.     FExprDataSize: Integer;
  66.     function FieldFromNode(Node: PExprNode): TField;
  67.     function GetExprData(Pos, Size: Integer): PChar;
  68.     function PutCompareNode(Node: PExprNode): Integer;
  69.     function PutConstBCD(const Value: Variant; Decimals: Integer): Integer;
  70.     function PutConstBool(const Value: Variant): Integer;
  71.     function PutConstDate(const Value: Variant): Integer;
  72.     function PutConstDateTime(const Value: Variant): Integer;
  73.     function PutConstFloat(const Value: Variant): Integer;
  74.     function PutConstInt(DataType: Integer; const Value: Variant): Integer;
  75.     function PutConstNode(DataType: Integer; Data: PChar;
  76.       Size: Integer): Integer;
  77.     function PutConstStr(const Value: string): Integer;
  78.     function PutConstTime(const Value: Variant): Integer;
  79.     function PutData(Data: PChar; Size: Integer): Integer;
  80.     function PutExprNode(Node: PExprNode): Integer;
  81.     function PutFieldNode(Field: TField): Integer;
  82.     function PutNode(NodeType: NodeClass; OpType: CanOp;
  83.       OpCount: Integer): Integer;
  84.     procedure SetNodeOp(Node, Index, Data: Integer);
  85.   public
  86.     constructor Create(DataSet: TDataSet; Options: TFilterOptions);
  87.     destructor Destroy; override;
  88.     function NewCompareNode(Field: TField; Operator: CanOp;
  89.       const Value: Variant): PExprNode;
  90.     function NewNode(Kind: TExprNodeKind; Operator: CanOp;
  91.       const Data: Variant; Left, Right: PExprNode): PExprNode;
  92.     function GetFilterData(Root: PExprNode): PCANExpr;
  93.   end;
  94.  
  95. { TExprParser }
  96.  
  97.   TExprToken = (etEnd, etSymbol, etName, etLiteral, etLParen, etRParen,
  98.     etEQ, etNE, etGE, etLE, etGT, etLT);
  99.  
  100.   TExprParser = class
  101.   private
  102.     FFilter: TFilterExpr;
  103.     FText: string;
  104.     FSourcePtr: PChar;
  105.     FTokenPtr: PChar;
  106.     FTokenString: string;
  107.     FStrTrue: string;
  108.     FStrFalse: string;
  109.     FToken: TExprToken;
  110.     FFilterData: PCANExpr;
  111.     FDataSize: Integer;
  112.     procedure NextToken;
  113.     function ParseExpr: PExprNode;
  114.     function ParseExpr2: PExprNode;
  115.     function ParseExpr3: PExprNode;
  116.     function ParseExpr4: PExprNode;
  117.     function ParseExpr5: PExprNode;
  118.     function TokenName: string;
  119.     function TokenSymbolIs(const S: string): Boolean;
  120.   public
  121.     constructor Create(DataSet: TDataSet; const Text: string;
  122.       Options: TFilterOptions);
  123.     destructor Destroy; override;
  124.     property FilterData: PCANExpr read FFilterData;
  125.     property DataSize: Integer read FDataSize;
  126.   end;
  127.  
  128. { TMasterDataLink }
  129.  
  130.   TMasterDataLink = class(TDataLink)
  131.   private
  132.     FDataSet: TDataSet;
  133.     FFieldNames: string;
  134.     FFields: TList;
  135.     FOnMasterChange: TNotifyEvent;
  136.     FOnMasterDisable: TNotifyEvent;
  137.     procedure SetFieldNames(const Value: string);
  138.   protected
  139.     procedure ActiveChanged; override;
  140.     procedure CheckBrowseMode; override;
  141.     procedure LayoutChanged; override;
  142.     procedure RecordChanged(Field: TField); override;
  143.   public
  144.     constructor Create(DataSet: TDataSet);
  145.     destructor Destroy; override;
  146.     property FieldNames: string read FFieldNames write SetFieldNames;
  147.     property Fields: TList read FFields;
  148.     property OnMasterChange: TNotifyEvent read FOnMasterChange write FOnMasterChange;
  149.     property OnMasterDisable: TNotifyEvent read FOnMasterDisable write FOnMasterDisable;
  150.   end;
  151.  
  152. function FMTBCDToCurr(const BCD: FMTBcd; var Curr: Currency): Boolean;
  153. function CurrToFMTBCD(Curr: Currency; var BCD: FMTBcd; Precision,
  154.   Decimals: Integer): Boolean;
  155. function SafeArrayToVariant(SafeArray: PVarArray): Variant;
  156.  
  157. implementation
  158.  
  159. uses SysUtils, DBConsts, BDEConst;  { ! Remove dependencies on BDEConts. }
  160.  
  161. function SafeArrayToVariant(SafeArray: PVarArray): Variant;
  162. begin
  163.   if Assigned(SafeArray) then
  164.   begin
  165.     VarClear(Result);
  166.     TVarData(Result).VType := varByte or varArray;
  167.     TVarData(Result).VArray := SafeArray;
  168.   end else
  169.     Result := NULL;
  170. end;
  171.  
  172. function FMTBCDToCurr(const BCD: FMTBcd; var Curr: Currency): Boolean;
  173. const
  174.   FConst10: Single = 10;
  175.   CWNear: Word = $133F;
  176. var
  177.   CtrlWord: Word;
  178.   Temp: Integer;
  179.   Digits: array[0..63] of Byte;
  180. asm
  181.         PUSH    EBX
  182.         PUSH    ESI
  183.         MOV     EBX,EAX
  184.         MOV     ESI,EDX
  185.         MOV     AL,0
  186.         MOVZX   EDX,[EBX].FMTBcd.iPrecision
  187.         OR      EDX,EDX
  188.         JE      @@8
  189.         LEA     ECX,[EDX+1]
  190.         SHR     ECX,1
  191. @@1:    MOV     AL,[EBX].FMTBcd.iFraction.Byte[ECX-1]
  192.         MOV     AH,AL
  193.         SHR     AL,4
  194.         AND     AH,0FH
  195.         MOV     Digits.Word[ECX*2-2],AX
  196.         DEC     ECX
  197.         JNE     @@1
  198.         XOR     EAX,EAX
  199. @@2:    MOV     AL,Digits.Byte[ECX]
  200.         OR      AL,AL
  201.         JNE     @@3
  202.         INC     ECX
  203.         CMP     ECX,EDX
  204.         JNE     @@2
  205.         FLDZ
  206.         JMP     @@7
  207. @@3:    MOV     Temp,EAX
  208.         FILD    Temp
  209. @@4:    INC     ECX
  210.         CMP     ECX,EDX
  211.         JE      @@5
  212.         FMUL    FConst10
  213.         MOV     AL,Digits.Byte[ECX]
  214.         MOV     Temp,EAX
  215.         FIADD   Temp
  216.         JMP     @@4
  217. @@5:    MOV     AL,[EBX].FMTBcd.iSignSpecialPlaces
  218.         OR      AL,AL
  219.         JNS     @@6
  220.         FCHS
  221. @@6:    AND     EAX,3FH
  222.         SUB     EAX,4
  223.         NEG     EAX
  224.         CALL    FPower10
  225. @@7:    FSTCW   CtrlWord
  226.         FLDCW   CWNear
  227.         FISTP   [ESI].Currency
  228.         FSTSW   AX
  229.         NOT     AL
  230.         AND     AL,1
  231.         FCLEX
  232.         FLDCW   CtrlWord
  233.         FWAIT
  234. @@8:    POP     ESI
  235.         POP     EBX
  236. end;
  237.  
  238. function CurrToFMTBCD(Curr: Currency; var BCD: FMTBcd; Precision,
  239.   Decimals: Integer): Boolean;
  240. const
  241.   Power10: array[0..3] of Single = (10000, 1000, 100, 10);
  242. var
  243.   Digits: array[0..63] of Byte;
  244. asm
  245.         PUSH    EBX
  246.         PUSH    ESI
  247.         PUSH    EDI
  248.         MOV     ESI,EAX
  249.         XCHG    ECX,EDX
  250.         MOV     [ESI].FMTBcd.iPrecision,CL
  251.         MOV     [ESI].FMTBcd.iSignSpecialPlaces,DL
  252. @@1:    SUB     EDX,4
  253.         JE      @@3
  254.         JA      @@2
  255.         FILD    Curr
  256.         FDIV    Power10.Single[EDX*4+16]
  257.         FISTP   Curr
  258.         JMP     @@3
  259. @@2:    DEC     ECX
  260.         MOV     Digits.Byte[ECX],0
  261.         DEC     EDX
  262.         JNE     @@2
  263. @@3:    MOV     EAX,Curr.Integer[0]
  264.         MOV     EBX,Curr.Integer[4]
  265.         OR      EBX,EBX
  266.         JNS     @@4
  267.         NEG     EBX
  268.         NEG     EAX
  269.         SBB     EBX,0
  270.         OR      [ESI].FMTBcd.iSignSpecialPlaces,80H
  271. @@4:    MOV     EDI,10
  272. @@5:    MOV     EDX,EAX
  273.         OR      EDX,EBX
  274.         JE      @@7
  275.         XOR     EDX,EDX
  276.         OR      EBX,EBX
  277.         JE      @@6
  278.         XCHG    EAX,EBX
  279.         DIV     EDI
  280.         XCHG    EAX,EBX
  281. @@6:    DIV     EDI
  282. @@7:    MOV     Digits.Byte[ECX-1],DL
  283.         DEC     ECX
  284.         JNE     @@5
  285.         OR      EAX,EBX
  286.         MOV     AL,0
  287.         JNE     @@9
  288.         MOV     CL,[ESI].FMTBcd.iPrecision
  289.         INC     ECX
  290.         SHR     ECX,1
  291. @@8:    MOV     AX,Digits.Word[ECX*2-2]
  292.         SHL     AL,4
  293.         OR      AL,AH
  294.         MOV     [ESI].FMTBcd.iFraction.Byte[ECX-1],AL
  295.         DEC     ECX
  296.         JNE     @@8
  297.         MOV     AL,1
  298. @@9:    POP     EDI
  299.         POP     ESI
  300.         POP     EBX
  301. end;
  302.  
  303. { TFilterExpr }
  304.  
  305. constructor TFilterExpr.Create(DataSet: TDataSet; Options: TFilterOptions);
  306. begin
  307.   FDataSet := DataSet;
  308.   FOptions := Options;
  309. end;
  310.  
  311. destructor TFilterExpr.Destroy;
  312. var
  313.   Node: PExprNode;
  314. begin
  315.   FreeMem(FExprBuffer, FExprBufSize);
  316.   while FNodes <> nil do
  317.   begin
  318.     Node := FNodes;
  319.     FNodes := Node^.FNext;
  320.     Dispose(Node);
  321.   end;
  322. end;
  323.  
  324. function TFilterExpr.FieldFromNode(Node: PExprNode): TField;
  325. begin
  326.   Result := FDataSet.FieldByName(Node^.FData);
  327.   if not (Result.FieldKind in [fkData, fkInternalCalc]) then
  328.     DatabaseErrorFmt(SExprBadField, [Result.FieldName]);
  329. end;
  330.  
  331. function TFilterExpr.GetExprData(Pos, Size: Integer): PChar;
  332. begin
  333.   ReallocMem(FExprBuffer, FExprBufSize + Size);
  334.   Move(PChar(FExprBuffer)[Pos], PChar(FExprBuffer)[Pos + Size],
  335.     FExprBufSize - Pos);
  336.   Inc(FExprBufSize, Size);
  337.   Result := PChar(FExprBuffer) + Pos;
  338. end;
  339.  
  340. function TFilterExpr.GetFilterData(Root: PExprNode): PCANExpr;
  341. begin
  342.   FExprBufSize := SizeOf(CANExpr);
  343.   GetMem(FExprBuffer, FExprBufSize);
  344.   PutExprNode(Root);
  345.   with FExprBuffer^ do
  346.   begin
  347.     iVer := CANEXPRVERSION;
  348.     iTotalSize := FExprBufSize;
  349.     iNodes := $FFFF;
  350.     iNodeStart := SizeOf(CANExpr);
  351.     iLiteralStart := FExprNodeSize + SizeOf(CANExpr);
  352.   end;
  353.   Result := FExprBuffer;
  354. end;
  355.  
  356. function TFilterExpr.NewCompareNode(Field: TField; Operator: CanOp;
  357.   const Value: Variant): PExprNode;
  358. begin
  359.   Result := NewNode(enOperator, Operator, Unassigned,
  360.     NewNode(enField, canNOTDEFINED, Field.FieldName, nil, nil),
  361.     NewNode(enConst, canNOTDEFINED, Value, nil, nil));
  362. end;
  363.  
  364. function TFilterExpr.NewNode(Kind: TExprNodeKind; Operator: CanOp;
  365.   const Data: Variant; Left, Right: PExprNode): PExprNode;
  366. begin
  367.   New(Result);
  368.   with Result^ do
  369.   begin
  370.     FNext := FNodes;
  371.     FKind := Kind;
  372.     FPartial := False;
  373.     FOperator := Operator;
  374.     FData := Data;
  375.     FLeft := Left;
  376.     FRight := Right;
  377.   end;
  378.   FNodes := Result;
  379. end;
  380.  
  381. function TFilterExpr.PutCompareNode(Node: PExprNode): Integer;
  382. const
  383.   ReverseOperator: array[canEQ..canLE] of CanOp = (
  384.     canEQ, canNE, canLT, canGT, canLE, canGE);
  385. var
  386.   Operator: CanOp;
  387.   Left, Right, Temp: PExprNode;
  388.   Field: TField;
  389.   FieldPos, ConstPos, CaseInsensitive, PartialLength, L: Integer;
  390.   S: string;
  391. begin
  392.   Operator := Node^.FOperator;
  393.   Left := Node^.FLeft;
  394.   Right := Node^.FRight;
  395.   if Right^.FKind = enField then
  396.   begin
  397.     Temp := Left;
  398.     Left := Right;
  399.     Right := Temp;
  400.     Operator := ReverseOperator[Operator];
  401.   end;
  402.   if (Left^.FKind <> enField) or (Right^.FKind <> enConst) then
  403.     DatabaseError(SExprBadCompare);
  404.   Field := FieldFromNode(Left);
  405.   if VarIsNull(Right^.FData) then
  406.   begin
  407.     case Operator of
  408.       canEQ: Operator := canISBLANK;
  409.       canNE: Operator := canNOTBLANK;
  410.     else
  411.       DatabaseError(SExprBadNullTest);
  412.     end;
  413.     Result := PutNode(nodeUNARY, Operator, 1);
  414.     SetNodeOp(Result, 0, PutFieldNode(Field));
  415.   end else
  416.   begin
  417.     if ((Operator = canEQ) or (Operator = canNE)) and
  418.       (Field.DataType = ftString) then
  419.     begin
  420.       S := Right^.FData;
  421.       L := Length(S);
  422.       if L <> 0 then
  423.       begin
  424.         CaseInsensitive := 0;
  425.         PartialLength := 0;
  426.         if foCaseInsensitive in FOptions then CaseInsensitive := 1;
  427.         if Node^.FPartial then PartialLength := L else
  428.           if not (foNoPartialCompare in FOptions) and (L > 1) and
  429.             (S[L] = '*') then
  430.           begin
  431.             Delete(S, L, 1);
  432.             PartialLength := L - 1;
  433.           end;
  434.         if (CaseInsensitive <> 0) or (PartialLength <> 0) then
  435.         begin
  436.           Result := PutNode(nodeCOMPARE, Operator, 4);
  437.           SetNodeOp(Result, 0, CaseInsensitive);
  438.           SetNodeOp(Result, 1, PartialLength);
  439.           SetNodeOp(Result, 2, PutFieldNode(Field));
  440.           SetNodeOp(Result, 3, PutConstStr(S));
  441.           Exit;
  442.         end;
  443.       end;
  444.     end;
  445.     Result := PutNode(nodeBINARY, Operator, 2);
  446.     FieldPos := PutFieldNode(Field);
  447.     case Field.DataType of
  448.       ftString:
  449.         ConstPos := PutConstStr(Right^.FData);
  450.       ftSmallint:
  451.         ConstPos := PutConstInt(fldINT16, Right^.FData);
  452.       ftInteger, ftAutoInc:
  453.         ConstPos := PutConstInt(fldINT32, Right^.FData);
  454.       ftWord:
  455.         ConstPos := PutConstInt(fldUINT16, Right^.FData);
  456.       ftFloat, ftCurrency:
  457.         ConstPos := PutConstFloat(Right^.FData);
  458.       ftBCD:
  459.         ConstPos := PutConstBCD(Right^.FData, Field.Size);
  460.       ftDate:
  461.         ConstPos := PutConstDate(Right^.FData);
  462.       ftTime:
  463.         ConstPos := PutConstTime(Right^.FData);
  464.       ftDateTime:
  465.         ConstPos := PutConstDateTime(Right^.FData);
  466.       ftBoolean:
  467.         ConstPos := PutConstBool(Right^.FData);
  468.     else
  469.       DatabaseErrorFmt(SExprBadField, [Field.FieldName]);
  470.       ConstPos := 0;
  471.     end;
  472.     SetNodeOp(Result, 0, FieldPos);
  473.     SetNodeOp(Result, 1, ConstPos);
  474.   end;
  475. end;
  476.  
  477. function TFilterExpr.PutConstBCD(const Value: Variant;
  478.   Decimals: Integer): Integer;
  479. var
  480.   C: Currency;
  481.   BCD: FMTBcd;
  482. begin
  483.   if VarType(Value) = varString then
  484.     C := StrToCurr(string(TVarData(Value).VString)) else
  485.     C := Value;
  486.   CurrToFMTBCD(C, BCD, 32, Decimals);
  487.   Result := PutConstNode(fldBCD, @BCD, 18);
  488. end;
  489.  
  490. function TFilterExpr.PutConstBool(const Value: Variant): Integer;
  491. var
  492.   B: WordBool;
  493. begin
  494.   B := Value;
  495.   Result := PutConstNode(fldBOOL, @B, SizeOf(WordBool));
  496. end;
  497.  
  498. function TFilterExpr.PutConstDate(const Value: Variant): Integer;
  499. var
  500.   DateTime: TDateTime;
  501.   TimeStamp: TTimeStamp;
  502. begin
  503.   if VarType(Value) = varString then
  504.     DateTime := StrToDate(string(TVarData(Value).VString)) else
  505.     DateTime := VarToDateTime(Value);
  506.   TimeStamp := DateTimeToTimeStamp(DateTime);
  507.   Result := PutConstNode(fldDATE, @TimeStamp.Date, 4);
  508. end;
  509.  
  510. function TFilterExpr.PutConstDateTime(const Value: Variant): Integer;
  511. var
  512.   DateTime: TDateTime;
  513.   DateData: Double;
  514. begin
  515.   if VarType(Value) = varString then
  516.     DateTime := StrToDateTime(string(TVarData(Value).VString)) else
  517.     DateTime := VarToDateTime(Value);
  518.   DateData := TimeStampToMSecs(DateTimeToTimeStamp(DateTime));
  519.   Result := PutConstNode(fldTIMESTAMP, @DateData, 8);
  520. end;
  521.  
  522. function TFilterExpr.PutConstFloat(const Value: Variant): Integer;
  523. var
  524.   F: Double;
  525. begin
  526.   if VarType(Value) = varString then
  527.     F := StrToFloat(string(TVarData(Value).VString)) else
  528.     F := Value;
  529.   Result := PutConstNode(fldFLOAT, @F, SizeOf(Double));
  530. end;
  531.  
  532. function TFilterExpr.PutConstInt(DataType: Integer;
  533.   const Value: Variant): Integer;
  534. var
  535.   I, Size: Integer;
  536. begin
  537.   if VarType(Value) = varString then
  538.     I := StrToInt(string(TVarData(Value).VString)) else
  539.     I := Value;
  540.   Size := 2;
  541.   case DataType of
  542.     fldINT16:
  543.       if (I < -32768) or (I > 32767) then DatabaseError(SExprRangeError);
  544.     fldUINT16:
  545.       if (I < 0) or (I > 65535) then DatabaseError(SExprRangeError);
  546.   else
  547.     Size := 4;
  548.   end;
  549.   Result := PutConstNode(DataType, @I, Size);
  550. end;
  551.  
  552. function TFilterExpr.PutConstNode(DataType: Integer; Data: PChar;
  553.   Size: Integer): Integer;
  554. begin
  555.   Result := PutNode(nodeCONST, canCONST2, 3);
  556.   SetNodeOp(Result, 0, DataType);
  557.   SetNodeOp(Result, 1, Size);
  558.   SetNodeOp(Result, 2, PutData(Data, Size));
  559. end;
  560.  
  561. function TFilterExpr.PutConstStr(const Value: string): Integer;
  562. var
  563.   Buffer: array[0..255] of Char;
  564. begin
  565.   FDataSet.Translate(PChar(Value), Buffer, True);
  566.   Result := PutConstNode(fldZSTRING, Buffer, Length(Value) + 1);
  567. end;
  568.  
  569. function TFilterExpr.PutConstTime(const Value: Variant): Integer;
  570. var
  571.   DateTime: TDateTime;
  572.   TimeStamp: TTimeStamp;
  573. begin
  574.   if VarType(Value) = varString then
  575.     DateTime := StrToTime(string(TVarData(Value).VString)) else
  576.     DateTime := VarToDateTime(Value);
  577.   TimeStamp := DateTimeToTimeStamp(DateTime);
  578.   Result := PutConstNode(fldTIME, @TimeStamp.Time, 4);
  579. end;
  580.  
  581. function TFilterExpr.PutData(Data: PChar; Size: Integer): Integer;
  582. begin
  583.   Move(Data^, GetExprData(FExprBufSize, Size)^, Size);
  584.   Result := FExprDataSize;
  585.   Inc(FExprDataSize, Size);
  586. end;
  587.  
  588. function TFilterExpr.PutExprNode(Node: PExprNode): Integer;
  589. const
  590.   BoolFalse: WordBool = False;
  591. var
  592.   Field: TField;
  593. begin
  594.   case Node^.FKind of
  595.     enField:
  596.       begin
  597.         Field := FieldFromNode(Node);
  598.         if Field.DataType <> ftBoolean then
  599.           DatabaseErrorFmt(SExprNotBoolean, [Field.FieldName]);
  600.         Result := PutNode(nodeBINARY, canNE, 2);
  601.         SetNodeOp(Result, 0, PutFieldNode(Field));
  602.         SetNodeOp(Result, 1, PutConstNode(fldBOOL, @BoolFalse,
  603.           SizeOf(WordBool)));
  604.       end;
  605.     enOperator:
  606.       case Node^.FOperator of
  607.         canEQ..canLE:
  608.           Result := PutCompareNode(Node);
  609.         canAND, canOR:
  610.           begin
  611.             Result := PutNode(nodeBINARY, Node^.FOperator, 2);
  612.             SetNodeOp(Result, 0, PutExprNode(Node^.FLeft));
  613.             SetNodeOp(Result, 1, PutExprNode(Node^.FRight));
  614.           end;
  615.       else
  616.         Result := PutNode(nodeUNARY, canNOT, 1);
  617.         SetNodeOp(Result, 0, PutExprNode(Node^.FLeft));
  618.       end;
  619.   else
  620.     DatabaseError(SExprIncorrect);
  621.     Result := 0;
  622.   end;
  623. end;
  624.  
  625. function TFilterExpr.PutFieldNode(Field: TField): Integer;
  626. var
  627.   Buffer: array[0..255] of Char;
  628. begin
  629.   FDataSet.Translate(PChar(Field.FieldName), Buffer, True);
  630.   Result := PutNode(nodeFIELD, canFIELD2, 2);
  631.   SetNodeOp(Result, 0, Field.FieldNo);
  632.   SetNodeOp(Result, 1, PutData(Buffer, StrLen(Buffer) + 1));
  633. end;
  634.  
  635. function TFilterExpr.PutNode(NodeType: NodeClass; OpType: CanOp;
  636.   OpCount: Integer): Integer;
  637. var
  638.   Size: Integer;
  639. begin
  640.   Size := SizeOf(CANHdr) + OpCount * SizeOf(Word);
  641.   with PCANHdr(GetExprData(SizeOf(CANExpr) + FExprNodeSize, Size))^ do
  642.   begin
  643.     nodeClass := NodeType;
  644.     canOp := OpType;
  645.   end;
  646.   Result := FExprNodeSize;
  647.   Inc(FExprNodeSize, Size);
  648. end;
  649.  
  650. procedure TFilterExpr.SetNodeOp(Node, Index, Data: Integer);
  651. begin
  652.   PWordArray(PChar(FExprBuffer) + (SizeOf(CANExpr) + Node +
  653.     SizeOf(CANHdr)))^[Index] := Data;
  654. end;
  655.  
  656. constructor TExprParser.Create(DataSet: TDataSet; const Text: string;
  657.   Options: TFilterOptions);
  658. var
  659.   Root: PExprNode;
  660. begin
  661.   FFilter := TFilterExpr.Create(DataSet, Options);
  662.   FStrTrue := STextTrue;
  663.   FStrFalse := STextFalse;
  664.   FText := Text;
  665.   FSourcePtr := PChar(Text);
  666.   NextToken;
  667.   Root := ParseExpr;
  668.   if FToken <> etEnd then DatabaseError(SExprTermination);
  669.   FFilterData := FFilter.GetFilterData(Root);
  670.   FDataSize := FFilter.FExprBufSize;
  671. end;
  672.  
  673. destructor TExprParser.Destroy;
  674. begin
  675.   FFilter.Free;
  676. end;
  677.  
  678. procedure TExprParser.NextToken;
  679. var
  680.   P, TokenStart: PChar;
  681.   L: Integer;
  682.   StrBuf: array[0..255] of Char;
  683. begin
  684.   FTokenString := '';
  685.   P := FSourcePtr;
  686.   while (P^ <> #0) and (P^ <= ' ') do Inc(P);
  687.   FTokenPtr := P;
  688.   case P^ of
  689.     'A'..'Z', 'a'..'z', '_':
  690.       begin
  691.         TokenStart := P;
  692.         Inc(P);
  693.         while P^ in ['A'..'Z', 'a'..'z', '0'..'9', '_'] do Inc(P);
  694.         SetString(FTokenString, TokenStart, P - TokenStart);
  695.         FToken := etSymbol;
  696.       end;
  697.     '[':
  698.       begin
  699.         Inc(P);
  700.         TokenStart := P;
  701.         P := AnsiStrScan(P, ']');
  702.         if P = nil then DatabaseError(SExprNameError);
  703.         SetString(FTokenString, TokenStart, P - TokenStart);
  704.         FToken := etName;
  705.         Inc(P);
  706.       end;
  707.     '''':
  708.       begin
  709.         Inc(P);
  710.         L := 0;
  711.         while True do
  712.         begin
  713.           if P^ = #0 then DatabaseError(SExprStringError);
  714.           if P^ = '''' then
  715.           begin
  716.             Inc(P);
  717.             if P^ <> '''' then Break;
  718.           end;
  719.           if L < SizeOf(StrBuf) then
  720.           begin
  721.             StrBuf[L] := P^;
  722.             Inc(L);
  723.           end;
  724.           Inc(P);
  725.         end;
  726.         SetString(FTokenString, StrBuf, L);
  727.         FToken := etLiteral;
  728.       end;
  729.     '-', '0'..'9':
  730.       begin
  731.         TokenStart := P;
  732.         Inc(P);
  733.         while P^ in ['0'..'9', '.', 'e', 'E', '+', '-'] do Inc(P);
  734.         SetString(FTokenString, TokenStart, P - TokenStart);
  735.         FToken := etLiteral;
  736.       end;
  737.     '(':
  738.       begin
  739.         Inc(P);
  740.         FToken := etLParen;
  741.       end;
  742.     ')':
  743.       begin
  744.         Inc(P);
  745.         FToken := etRParen;
  746.       end;
  747.     '<':
  748.       begin
  749.         Inc(P);
  750.         case P^ of
  751.           '=':
  752.             begin
  753.               Inc(P);
  754.               FToken := etLE;
  755.             end;
  756.           '>':
  757.             begin
  758.               Inc(P);
  759.               FToken := etNE;
  760.             end;
  761.         else
  762.           FToken := etLT;
  763.         end;
  764.       end;
  765.     '=':
  766.       begin
  767.         Inc(P);
  768.         FToken := etEQ;
  769.       end;
  770.     '>':
  771.       begin
  772.         Inc(P);
  773.         if P^ = '=' then
  774.         begin
  775.           Inc(P);
  776.           FToken := etGE;
  777.         end else
  778.           FToken := etGT;
  779.       end;
  780.     #0:
  781.       FToken := etEnd;
  782.   else
  783.     DatabaseErrorFmt(SExprInvalidChar, [P^]);
  784.   end;
  785.   FSourcePtr := P;
  786. end;
  787.  
  788. function TExprParser.ParseExpr: PExprNode;
  789. begin
  790.   Result := ParseExpr2;
  791.   while TokenSymbolIs('OR') do
  792.   begin
  793.     NextToken;
  794.     Result := FFilter.NewNode(enOperator, canOR, Unassigned,
  795.       Result, ParseExpr2);
  796.   end;
  797. end;
  798.  
  799. function TExprParser.ParseExpr2: PExprNode;
  800. begin
  801.   Result := ParseExpr3;
  802.   while TokenSymbolIs('AND') do
  803.   begin
  804.     NextToken;
  805.     Result := FFilter.NewNode(enOperator, canAND, Unassigned,
  806.       Result, ParseExpr3);
  807.   end;
  808. end;
  809.  
  810. function TExprParser.ParseExpr3: PExprNode;
  811. begin
  812.   if TokenSymbolIs('NOT') then
  813.   begin
  814.     NextToken;
  815.     Result := FFilter.NewNode(enOperator, canNOT, Unassigned,
  816.       ParseExpr4, nil);
  817.   end else
  818.     Result := ParseExpr4;
  819. end;
  820.  
  821. function TExprParser.ParseExpr4: PExprNode;
  822. const
  823.   Operators: array[etEQ..etLT] of CanOp = (
  824.     canEQ, canNE, canGE, canLE, canGT, canLT);
  825. var
  826.   Operator: CanOp;
  827. begin
  828.   Result := ParseExpr5;
  829.   if FToken in [etEQ..etLT] then
  830.   begin
  831.     Operator := Operators[FToken];
  832.     NextToken;
  833.     Result := FFilter.NewNode(enOperator, Operator, Unassigned,
  834.       Result, ParseExpr5);
  835.   end;
  836. end;
  837.  
  838. function TExprParser.ParseExpr5: PExprNode;
  839. begin
  840.   case FToken of
  841.     etSymbol:
  842.       if TokenSymbolIs('NULL') then
  843.         Result := FFilter.NewNode(enConst, canNOTDEFINED, System.Null, nil, nil)
  844.       else if TokenSymbolIs(FStrTrue) then
  845.         Result := FFilter.NewNode(enConst, canNOTDEFINED, 1, nil, nil)
  846.       else if TokenSymbolIs(FStrFalse) then
  847.         Result := FFilter.NewNode(enConst, canNOTDEFINED, 0, nil, nil)
  848.       else
  849.         Result := FFilter.NewNode(enField, canNOTDEFINED, FTokenString, nil, nil);
  850.     etName:
  851.       Result := FFilter.NewNode(enField, canNOTDEFINED, FTokenString, nil, nil);
  852.     etLiteral:
  853.       Result := FFilter.NewNode(enConst, canNOTDEFINED, FTokenString, nil, nil);
  854.     etLParen:
  855.       begin
  856.         NextToken;
  857.         Result := ParseExpr;
  858.         if FToken <> etRParen then DatabaseErrorFmt(SExprNoRParen, [TokenName]);
  859.       end;
  860.   else
  861.     DatabaseErrorFmt(SExprExpected, [TokenName]);
  862.     Result := nil;
  863.   end;
  864.   NextToken;
  865. end;
  866.  
  867. function TExprParser.TokenName: string;
  868. begin
  869.   if FSourcePtr = FTokenPtr then Result := SExprNothing else
  870.   begin
  871.     SetString(Result, FTokenPtr, FSourcePtr - FTokenPtr);
  872.     Result := '''' + Result + '''';
  873.   end;
  874. end;
  875.  
  876. function TExprParser.TokenSymbolIs(const S: string): Boolean;
  877. begin
  878.   Result := (FToken = etSymbol) and (CompareText(FTokenString, S) = 0);
  879. end;
  880.  
  881. { TMasterDataLink }
  882.  
  883. constructor TMasterDataLink.Create(DataSet: TDataSet);
  884. begin
  885.   inherited Create;
  886.   FDataSet := DataSet;
  887.   FFields := TList.Create;
  888. end;
  889.  
  890. destructor TMasterDataLink.Destroy;
  891. begin
  892.   FFields.Free;
  893.   inherited Destroy;
  894. end;
  895.  
  896. procedure TMasterDataLink.ActiveChanged;
  897. begin
  898.   FFields.Clear;
  899.   if Active then
  900.     try
  901.       DataSet.GetFieldList(FFields, FFieldNames);
  902.     except
  903.       FFields.Clear;
  904.       raise;
  905.     end;
  906.   if FDataSet.Active and not (csDestroying in FDataSet.ComponentState) then
  907.     if Active and (FFields.Count > 0) then
  908.     begin
  909.       if Assigned(FOnMasterChange) then FOnMasterChange(Self);
  910.     end else
  911.       if Assigned(FOnMasterDisable) then FOnMasterDisable(Self);
  912. end;
  913.  
  914. procedure TMasterDataLink.CheckBrowseMode;
  915. begin
  916.   if FDataSet.Active then FDataSet.CheckBrowseMode;
  917. end;
  918.  
  919. procedure TMasterDataLink.LayoutChanged;
  920. begin
  921.   ActiveChanged;
  922. end;
  923.  
  924. procedure TMasterDataLink.RecordChanged(Field: TField);
  925. begin
  926.   if (DataSource.State <> dsSetKey) and FDataSet.Active and
  927.     (FFields.Count > 0) and ((Field = nil) or
  928.     (FFields.IndexOf(Field) >= 0)) and
  929.      Assigned(FOnMasterChange) then
  930.     FOnMasterChange(Self);
  931. end;
  932.  
  933. procedure TMasterDataLink.SetFieldNames(const Value: string);
  934. begin
  935.   if FFieldNames <> Value then
  936.   begin
  937.     FFieldNames := Value;
  938.     ActiveChanged;
  939.   end;
  940. end;
  941.  
  942.  
  943. end.
  944.